home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Collection of Tools & Utilities
/
Collection of Tools and Utilities.iso
/
clipper
/
rlib20.zip
/
RL_BOXME.PRG
< prev
next >
Wrap
Text File
|
1989-02-18
|
6KB
|
179 lines
* Function..: BOXMENU
* Author....: Richard Low
* Syntax....: BOXMENU( row, column, options [,choice [,altkeys [,exitkeys
* [,prompts [,prompt_row [,colors ]]]]]]] )
* Returns...: Number of array element option picked, or 0 if escape pressed.
* Parameters: row - Top row to start box menu
* column - Top left column of menu box
* options - Array of menu option choices
* choice - Optional starting array element number
* altkeys - Optional list of alternate selection keys
* exitkeys - Optional list of keys to cause a 0 return value exit
* Pass a null string to skip (default = escape)
* Pass .F. to disable 0 return value exit altogether
* prompts - Optional array of menu option messages
* promptrow - Optional row number on which these messages appear
* colors - Optional character string of colors to use in menu
* Notes.....: If an optional parameters is skipped, you must pass a dummy in
* its place.
FUNCTION BOXMENU
PARAMETERS p_row, p_col, p_options, p_choice, p_altkeys, p_exitkeys,;
p_prompts, p_prmtrow, p_colors
PRIVATE f_prompton, f_incolor, f_maxwide, f_junk, f_canexit, f_x, f_lkey,;
f_display, f_menubar, f_box_on, f_box_off, f_selected
*-- check that first 3 parameters are passed and correct type
IF TYPE('p_row') + TYPE('p_col') + TYPE('p_options') != 'NNA'
RETURN 0
ENDIF
*-- see if row,column is in range, if not, default to row,column 1,1
p_row = IF( p_row > 24, 1, p_row )
p_col = IF( p_col > 79, 1, p_col )
*-- if p_choice specified make sure it is in range, else default to option 1
p_choice = IF( TYPE('p_choice') = 'N', MIN(MAX(p_choice,1),LEN(p_options)), 1 )
*-- messages displayed only if parm is of type array
f_prompton = ( TYPE('p_prompts') = 'A' )
*-- messages displayed on line 24 unles otherwise specified
p_prmtrow = IF( TYPE('p_prmtrow') = 'N', p_prmtrow, 24 )
*-- save incoming color
STORE SETCOLOR() TO f_incolor
*-- use <color array> if it is an array AND it has at least 5 elements
IF IF( TYPE('p_colors') = 'A', IF(LEN(p_colors) >= 5, .T., .F.) , .F. )
f_display = p_colors[1] && display color
f_menubar = p_colors[2] && menu bar color
f_box_on = p_colors[3] && active box color
f_box_off = p_colors[4] && box border after exit
f_selected = p_colors[5] && selected option color
ELSE
STORE SETCOLOR() TO f_display, f_box_off
STORE BRIGHT() TO f_box_on, f_selected
f_menubar = GETPARM(2,f_incolor)
ENDIF
*-- change column number to one to right of the box to avoid lots of math
p_col = p_col + 1
*-- display options, find max width, and build list of first letter pick keys
f_junk = ''
f_maxwide = 1
SETCOLOR(f_display)
FOR f_x = 1 TO LEN(p_options)
@ p_row+f_x,p_col SAY p_options[f_x]
f_maxwide = MAX( f_maxwide, LEN(p_options[f_x]) )
f_junk = f_junk + SUBSTR( LTRIM(p_options[f_x]),1,1 )
NEXT f_x
*-- now draw the box for the menu using the maximum width of options
*-- making the active box a double line box
SETCOLOR(f_box_on)
@ p_row, p_col-1, p_row+LEN(p_options)+1, p_col+f_maxwide BOX '╔═╗║╝═╚║'
*-- now add any alternate pick keys passed as parameters to the list, if any
p_altkeys = IF( TYPE('p_altkeys') = 'C', f_junk + p_altkeys, f_junk )
*-- if a Logical was passed in place of exit keys, disable exit feature
f_canexit = IF( TYPE('p_exitkeys') = 'L', p_exitkeys, .T. )
*-- see if any exit keys were passed (and not empty), else default to Escape
p_exitkeys = IF( TYPE('p_exitkeys') = 'C', p_exitkeys, CHR(27) )
p_exitkeys = IF( .NOT. EMPTY(p_exitkeys), p_exitkeys, CHR(27) )
DO WHILE .T.
*-- display current selection in desired highlite video
SETCOLOR(f_menubar)
@ p_row+p_choice,p_col SAY p_options[p_choice]
*-- if message prompts are on, clear row and display
IF f_prompton
SETCOLOR(f_incolor)
@ p_prmtrow,0
@ p_prmtrow,(80-LEN(p_prompts[p_choice]))/2 SAY p_prompts[p_choice]
ENDIF
*-- reset display color
SETCOLOR(f_display)
*-- wait for a key
f_lkey = INKEY(0)
DO CASE
CASE f_lkey = 24
*-- Down Arrow
@ p_row+p_choice,p_col SAY p_options[p_choice]
p_choice = IF( p_choice = LEN(p_options), 1, p_choice + 1 )
CASE f_lkey = 5
*-- Up Arrow or Back Space
@ p_row+p_choice,p_col SAY p_options[p_choice]
p_choice = IF( p_choice = 1, LEN(p_options), p_choice - 1 )
CASE f_lkey = 1
*-- Home Key
@ p_row+p_choice,p_col SAY p_options[p_choice]
p_choice = 1
CASE f_lkey = 6
*-- End key
@ p_row+p_choice,p_col SAY p_options[p_choice]
p_choice = LEN(p_options)
CASE f_lkey = 13
*-- Enter key
EXIT
CASE UPPER(CHR(f_lkey)) $ p_altkeys
@ p_row+p_choice,p_col SAY p_options[p_choice]
f_x = 1
p_choice = 0
DO WHILE p_choice = 0
p_choice = AT(UPPER(CHR(f_lkey)),SUBSTR(p_altkeys,f_x,LEN(p_options)))
f_x = f_x + LEN(p_options)
ENDDO
EXIT
CASE f_canexit
IF UPPER(CHR(f_lkey)) $ p_exitkeys
*-- Escape request
p_choice = 0
EXIT
ENDIF
ENDCASE
ENDDO
*-- display selected option in selected color
IF p_choice > 0 .AND. p_choice <= LEN(p_options)
SETCOLOR(f_selected)
@ p_row+p_choice,p_col SAY p_options[p_choice]
*-- redraw box in in-active box color
SETCOLOR(f_box_off)
@ p_row, p_col-1, p_row+LEN(p_options)+1, p_col+f_maxwide BOX '┌─┐│┘─└│'
ENDIF
*-- restore original color
SETCOLOR(f_incolor)
*-- clear message line
IF f_prompton
@ p_prmtrow,0
ENDIF
RETURN p_choice